home *** CD-ROM | disk | FTP | other *** search
/ Aminet 28 / Aminet 28 (1998)(GTI - Schatztruhe)[!][Dec 1998].iso / Aminet / dev / lang / fpcsrc.lha / fpc / compiler / cga68k.pas < prev    next >
Pascal/Delphi Source File  |  1998-09-24  |  58KB  |  1,430 lines
  1. {
  2.     $Id: cga68k.pas,v 1.2.2.7 1998/08/14 12:04:36 carl Exp $
  3.     Copyright (c) 1993-98 by Florian Klaempfl, Carl Eric Codere
  4.  
  5.     This unit generates 68000 (or better) assembler from the parse tree
  6.  
  7.     This program is free software; you can redistribute it and/or modify
  8.     it under the terms of the GNU General Public License as published by
  9.     the Free Software Foundation; either version 2 of the License, or
  10.     (at your option) any later version.
  11.  
  12.     This program is distributed in the hope that it will be useful,
  13.     but WITHOUT ANY WARRANTY; without even the implied warranty of
  14.     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15.     GNU General Public License for more details.
  16.  
  17.     You should have received a copy of the GNU General Public License
  18.     along with this program; if not, write to the Free Software
  19.     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21.  ****************************************************************************
  22. }
  23. unit cga68k;
  24.  
  25.   interface
  26.  
  27.     uses
  28.        objects,cobjects,verbose,systems,globals,tree,symtable,types,strings,
  29.        pass_1,hcodegen,aasm,m68k,tgen68k,files,gdb;
  30.  
  31.     procedure emitl(op : tasmop;var l : plabel);
  32.     procedure emit_reg_reg(i : tasmop;s : topsize;reg1,reg2 : tregister);
  33.     procedure emitcall(const routine:string;add_to_externals : boolean);
  34.     procedure emitloadord2reg(location:Tlocation;orddef:Porddef;
  35.                               destreg:Tregister;delloc:boolean);
  36.     { produces jumps to true respectively false labels using boolean expressions }
  37.     procedure maketojumpbool(p : ptree);
  38.     procedure emitoverflowcheck(p: ptree);
  39.     procedure push_int(l : longint);
  40.     function maybe_push(needed : byte;p : ptree) : boolean;
  41.     procedure restore(p : ptree);
  42.     procedure emit_push_mem(const ref : treference);
  43.     procedure emitpushreferenceaddr(const ref : treference);
  44.     procedure swaptree(p: ptree);
  45.     procedure copystring(const dref,sref : treference;len : byte);
  46.     procedure concatcopy(source,dest : treference;size : longint;delsource : boolean);
  47.     { see implementation }
  48.     procedure maybe_loada5;
  49.     procedure emit_bounds_check(hp: treference; index: tregister);
  50.     procedure loadstring(p:ptree);
  51.  
  52.     procedure floatload(t : tfloattype;const ref : treference; var location:tlocation);
  53.     { return a float op_size from a floatb type  }
  54.     { also does some error checking for problems }
  55.     function getfloatsize(t: tfloattype): topsize;
  56.     procedure floatstore(t : tfloattype;var location:tlocation; const ref:treference);
  57. {    procedure floatloadops(t : tfloattype;var op : tasmop;var s : topsize);
  58.     procedure floatstoreops(t : tfloattype;var op : tasmop;var s : topsize); }
  59.  
  60.     procedure firstcomplex(p : ptree);
  61.     procedure secondfuncret(var p : ptree);
  62.  
  63.     { initialize respectively terminates the code generator }
  64.     { for a new module or procedure                         }
  65.     procedure codegen_doneprocedure;
  66.     procedure codegen_donemodule;
  67.     procedure codegen_newmodule;
  68.     procedure codegen_newprocedure;
  69.  
  70.     { generate entry code for a procedure.}
  71.     procedure genentrycode(const proc_names:Tstringcontainer;make_global:boolean;
  72.                            stackframe:longint;
  73.                            var parasize:longint;var nostackframe:boolean);
  74.     { generate the exit code for a procedure. }
  75.     procedure genexitcode(parasize:longint;nostackframe:boolean);
  76.  
  77.  
  78.   implementation
  79.  
  80.     {
  81.     procedure genconstadd(size : topsize;l : longint;const str : string);
  82.  
  83.       begin
  84.          if l=0 then
  85.          else if l=1 then
  86.            exprasmlist^.concat(new(pai68k,op_A_INC,size,str)
  87.          else if l=-1 then
  88.            exprasmlist^.concat(new(pai68k,op_A_INC,size,str)
  89.          else
  90.            exprasmlist^.concat(new(pai68k,op_ADD,size,'$'+tostr(l)+','+str);
  91.       end;
  92.     }
  93.     procedure copystring(const dref,sref : treference;len : byte);
  94.  
  95.       var
  96.          pushed : tpushed;
  97.  
  98.       begin
  99.          pushusedregisters(pushed,$ffff);
  100. {         emitpushreferenceaddr(dref);       }
  101. {         emitpushreferenceaddr(sref);       }
  102. {         push_int(len);                     }
  103.          { This speeds up from 116 cycles to 24 cycles on the 68000 }
  104.          { when passing register parameters!                        }
  105.          exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,newreference(dref),R_A1)));
  106.          exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,newreference(sref),R_A0)));
  107.          exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_L,len,R_D0)));
  108.          emitcall('STRCOPY',true);
  109.          maybe_loada5;
  110.          popusedregisters(pushed);
  111.       end;
  112.  
  113.  
  114.     procedure loadstring(p:ptree);
  115.       begin
  116.         case p^.right^.resulttype^.deftype of
  117.          stringdef : begin
  118.                        { load a string ... }
  119.                        { here two possible choices:      }
  120.                        { if it is a char, then simply    }
  121.                        { load 0 length string            }
  122.                        if (p^.right^.treetype=stringconstn) and
  123.                           (p^.right^.values^='') then
  124.                         exprasmlist^.concat(new(pai68k,op_const_ref(
  125.                            A_MOVE,S_B,0,newreference(p^.left^.location.reference))))
  126.                        else
  127.                         copystring(p^.left^.location.reference,p^.right^.location.reference,
  128.                            min(pstringdef(p^.right^.resulttype)^.len,pstringdef(p^.left^.resulttype)^.len));
  129.                      end;
  130.             orddef : begin
  131.                        if p^.right^.treetype=ordconstn then
  132.                         begin
  133.                             { offset 0: length of string }
  134.                             { offset 1: character        }
  135.                             exprasmlist^.concat(new(pai68k,op_const_ref(A_MOVE,S_W,1*256+p^.right^.value,
  136.                               newreference(p^.left^.location.reference))))
  137.                         end
  138.                        else
  139.                          begin
  140.                             { not so elegant (goes better with extra register }
  141.                             if (p^.right^.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then
  142.                               begin
  143.                                  exprasmlist^.concat(new(pai68k,op_reg_reg(
  144.                                     A_MOVE,S_B,p^.right^.location.register,R_D0)));
  145.                                  ungetregister32(p^.right^.location.register);
  146.                               end
  147.                             else
  148.                               begin
  149.                                  exprasmlist^.concat(new(pai68k,op_ref_reg(
  150.                                     A_MOVE,S_B,newreference(p^.right^.location.reference),R_D0)));
  151.                                  del_reference(p^.right^.location.reference);
  152.                               end;
  153.                             { alignment can cause problems }
  154.                             { add length of string to ref }
  155.                             exprasmlist^.concat(new(pai68k,op_const_ref(A_MOVE,S_B,1,
  156.                                newreference(p^.left^.location.reference))));
  157. (*                            if abs(p^.left^.location.reference.offset) >= 1 then
  158.                               Begin *)
  159.                               { temporarily decrease offset }
  160.                                 Inc(p^.left^.location.reference.offset);
  161.                                  exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,S_B,R_D0,
  162.                                   newreference(p^.left^.location.reference))));
  163.                                 Dec(p^.left^.location.reference.offset);
  164.                                 { restore offset }
  165. (*                              end
  166.                             else
  167.                               Begin
  168.                                 Comment(V_Debug,'SecondChar2String() internal error.');
  169.                                 internalerror(34);
  170.                               end; *)
  171.                          end;
  172.                        end;
  173.         else
  174.          Message(sym_e_type_mismatch);
  175.         end;
  176.       end;
  177.  
  178.  
  179.  
  180.  
  181.  
  182.     procedure restore(p : ptree);
  183.  
  184.       var
  185.          hregister :  treg